home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / save.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  6.3 KB  |  275 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # manage saving and loading project files
  8. # this is temporary! 
  9.  
  10. set Version 0.1
  11. set Id "WidGet file"
  12. proc save_project {file {compile 0}} {
  13.     dputs "Saving $file"
  14.     global Widgets _Message Id P Current Version
  15.     global Widget_data f
  16.  
  17.     catch {exec "mv -f $file ${file}-old"}
  18.     if {[catch "open $file w" fd]} {
  19.         set _Message "Can't open file $file"
  20.         return 0
  21.     }
  22.     puts $fd "$Id, version $Version, created:  [exec date]"
  23.     set Current(project) [file root $file]
  24.     set_title $Current(project)
  25.     set Current(dirty) ""
  26.  
  27.     # compute geometry options (fix padding name clash)
  28.     blt_get .can geom
  29.  
  30.     set f(level) 0
  31.     set_frame_level .can.f
  32.     outline_inhibit 1
  33.     foreach item "f [array names Widgets]" {
  34.         dputs "saving $item to $file"
  35.         set _Message "saving $item"
  36.         update
  37.         puts $fd "Widget $item"
  38.         if {$item == "f"} {
  39.             widget_extract .can.f
  40.         } else {
  41.             widget_extract .can.f.$item
  42.         }
  43.         upvar #0 $item data
  44.         set class $data(type)
  45.         foreach i [array names data] {
  46.  
  47.             # figure out what "type" of option we have
  48.             # since {,i}pad[xy] are used both for geometry
  49.             # and configuration, handle them specially
  50.  
  51.             # skip configuration values that are defaulted!
  52.             # This doesn't catch equivalent forms of the
  53.             # same value
  54.  
  55.             set skip 0
  56.             foreach type "$class geometry table" {
  57.                 if {![catch {set default $Widget_data(default:$type,$i)}]} {
  58.                     if {[string compare $default [list $data($i)]] == 0} {
  59.                         incr skip
  60.                         break
  61.                     }
  62.                 }
  63.             }
  64.             if {$skip} continue
  65.  
  66.             set map $i
  67.             if {[info exists Widget_data(default:$class,$i)]} {
  68.                 set type configure
  69.             } elseif {[info exists geom(-$i)]} {
  70.                 set type geometry
  71.             } elseif {[string match *wad* $i]} {
  72.                 set type geometry
  73.                 regsub wad $i pad map
  74.             } elseif {[string match *align $i]} {
  75.                 set type geometry
  76.                 regsub align $i anchor map
  77.             } else {
  78.                 set type other
  79.             }
  80.  
  81.             # run the input conversion filters
  82.             set value $data($i)
  83.             if {[info exists Widget_data(infilter:$i)]} {
  84.                 $Widget_data(infilter:$i) value
  85.                 dputs "filtering $i"
  86.             }
  87.             puts $fd \t[list $type $map $value]
  88.         }
  89.     }
  90.     outline_inhibit 0
  91.     close $fd
  92.     update idletasks
  93.     if {$compile} {
  94.         set _Message "Generating Tcl code"
  95.         update idletasks
  96.         compile $Current(project).ui $Current(project).ui.tcl
  97.     }
  98.     set _Message "save completed"
  99. }
  100.  
  101. # load a project it.  Must be in EMPTY grid
  102. # Well, maybe not!, just avoid name clashes!
  103. # This should be combined with the widget creation for 
  104. # both mouse-based widget creation and undo
  105. # This is a temporary hack!!
  106.  
  107. proc load_project {file {master .can.f}} {
  108.     global Widgets _Message Id Frames P Widget_data Current
  109.  
  110.     set _Message "loading project $file"
  111.     update idletasks
  112.     if {![file readable $file]} {
  113.         set _Message "$file does not exist"
  114.         return 0
  115.     }
  116.  
  117.     set fd [open $file r]
  118.     set line ""
  119.     gets $fd line
  120.     if {[string first $Id $line] != 0} {
  121.         set _Message "$file is not a UI file"
  122.         close $fd
  123.         return 0
  124.     }
  125.  
  126.     # clear the slate, or abort
  127.  
  128.     if {$Current(dirty) != "" || [array names Widgets] != ""} {
  129.         if {![clear_all]}  {
  130.             close $fd
  131.             return 0
  132.         }
  133.     }
  134.  
  135.     # read in the sucker!!
  136.  
  137.     set Current(project) [file root $file]
  138.     set_title $Current(project)
  139.     set Current(dirty) ""
  140.  
  141.  
  142.     while {1} {
  143.         gets $fd line
  144.         if {[eof $fd]} break
  145.  
  146.         # gather entire line
  147.  
  148.         while {![info complete $line]} {
  149.             append line \n[gets $fd]
  150.             dputs gulp
  151.             }
  152.  
  153.         # look for a keyword (only widget for now)
  154.  
  155.         if {[string first Widget $line] == 0} {
  156.             set name [lindex $line 1]
  157.             global $name
  158.             set Widgets($name) 1
  159.             continue
  160.         }
  161.         array set $name [lrange $line 1 end]
  162.     }
  163.     close $fd
  164.  
  165.     # create and manage the widgets
  166.     # Sort first, so frames get made first
  167.  
  168.     foreach name [lsort -command sort_widgets2 [array names Widgets]] {
  169.         upvar #0 $name data
  170.         dputs "Making widgets $name"
  171.  
  172.         if {$name == "f"} {
  173.             make_decorations .can.f
  174.             # zap all existing arrows, then create new ones
  175.             continue
  176.         }
  177.  
  178.         update_widget_counters $name
  179.  
  180.         # filter the font
  181.  
  182.         if {[info exists data(font)]} {
  183.             set value $data(font)
  184.             $Widget_data(outfilter:font) dummy font value
  185.             set data(font) $value
  186.         }
  187.  
  188.         # the rows and columns
  189.  
  190.         foreach dim {row column} {
  191.             if {![info exists data($dim)]} {
  192.                 set data($dim) 2
  193.             } else {
  194.                 set data($dim) [expr $data($dim) * 2]
  195.             }
  196.         }
  197.         # the rows and columns spans
  198.  
  199.         foreach dim {rowspan columnspan} {
  200.             if {![info exists data($dim)]} {
  201.                 set data($dim) 1
  202.             } else {
  203.                 set data($dim) [expr $data($dim) * 2 -1]
  204.             }
  205.         }
  206.  
  207.         # make the widget, set the bindings
  208.  
  209.         widget_configure $name
  210.         outline_create $name
  211.         widget_extract .can.f.$name    ;# add default options to array
  212.         if {[info exists data(resize_row)]} {
  213.             bindtags .can.f.$name "frame widget [bindtags .can.f.$name]"
  214.             make_decorations .can.f.$name
  215.         } else {
  216.             bindtags .can.f.$name "widget [bindtags .can.f.$name]"
  217.         }
  218.  
  219.         set done($name) 1
  220.     }
  221.     arrow_activate .can .can.f
  222. }
  223.  
  224. # sort a list of widgets so the "masters" always get made first
  225. # this will be called from qsort
  226. #  - Frames go in front of widgets
  227. #  - Master frames go in front of their children
  228.  
  229. proc sort_widgets2 {w1 w2} {
  230.     upvar #0 $w1 a $w2 b
  231.     
  232.     if {$a(type) != "frame" && $b(type) != "frame"} {return 0}
  233.     if {$a(type) != "frame"}  {return 1}
  234.     if {$b(type) != "frame"}  {return -1}
  235.  
  236.     # both frames look for child master relationship
  237.  
  238.     if {$a(master) == $w2} {return 1}
  239.     if {$b(master) == $w1} {return -1}
  240.     return 0
  241. }
  242.  
  243. # make the grid lines, arrows, etc
  244.  
  245. proc make_decorations {master} {
  246.     global P Frames
  247.     upvar #0 [winfo name $master] data
  248.     grid_create $master [expr 1 + 2 * [llength $data(resize_row)]] \
  249.             [expr 1 + 2 * [llength $data(resize_column)]] \
  250.             $P(grid_size) $P(can_bg)
  251.     blt_table arrange $master
  252.     set Frames($master) 1
  253.     table_setup $master
  254.  
  255.     arrow_create .can_row row $master all
  256.     arrow_create .can_column column $master all
  257.     arrow_shapeall .can $master row
  258.     arrow_shapeall .can $master column
  259.     arrow_activate .can $master
  260. }
  261.  
  262. # make sure the Next_widget counters are set properly
  263. #  name:        the "itemname"
  264.  
  265. proc update_widget_counters {name} {
  266.     global Next_widget
  267.     dputs $name
  268.     if {![regexp  {([^#]*)#([0-9]*)} $name dummy name count]} return
  269.     dputs $name -> $name $count
  270.     if {[info exists Next_widget($name)] && $Next_widget($name) < $count} {
  271.         dputs $name $count -> $Next_widget($name)
  272.         set Next_widget($name) $count
  273.     }
  274. }
  275.